home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / TOPLEVEL.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  6.7 KB  |  198 lines
  1. ; TOPLEVEL.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Standard Scheme Top-Level Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 1 Jun 87:    modified runtime-system toplevel handling so it works    *
  18. ;*        identically to the compiler version; this gets rid of    *
  19. ;*        APPLICATION-TOP-LEVEL, and PATCH.PCS and .INI handling    *
  20. ;*        will get executed in the runtime system    (rb)        *
  21. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  22. ;*                                    *
  23. ;*                    ``In nomine omnipotentii dei''    *
  24. ;************************************************************************
  25.  
  26. (begin
  27.   (define reset-scheme-top-level                ; SCHEME-TOP-LEVEL
  28.     (let ((saved-genv user-initial-environment))
  29.       (lambda ()
  30.     (letrec
  31.      ((==reset== '())
  32.       (==scheme-reset==            ; here for SCHEME-RESET
  33.        (lambda ()
  34.          (%set-global-environment saved-genv)
  35.          (set! (fluid input-port) standard-input)
  36.          (set! (fluid output-port) standard-output)
  37.          (putprop '%PCS-STL-HISTORY (list '()) %pcs-stl-history)
  38. ;         (full-screen)
  39.          (newline)
  40.          (display "[PCS-DEBUG-MODE is ")
  41.          (display (if pcs-debug-mode "ON" "OFF"))
  42.          (if pcs-machine-type
  43.          (let ((cpu (caar pcs-machine-type))
  44.                (ndp (cadr pcs-machine-type)))
  45.            (display ", machine is 80") (display cpu)
  46.            (display " at ") (display (cdar pcs-machine-type))
  47.            (display " MHz with ")
  48.            (display (if (= ndp 0) "no" (if (= cpu 486) "built-in"
  49.                   (begin (display "80") ndp))))
  50.            (display " coprocessor")))
  51.          (display "]")
  52.          (newline)
  53.          (call/cc (lambda (k)
  54.             (set! ==reset== (lambda ()(k '())))
  55.             (set! (fluid scheme-top-level)
  56.                   ==reset==)))
  57.                         ; here for RESET (if fluid
  58.                         ; SCHEME-TOP-LEVEL hasn't been redefined;
  59.                         ; if it has, restart that function)
  60.          (pcs-kill-engine)
  61.          (gc)            ; restore WHO line  (temporary)
  62.          (more)))
  63.       (more
  64.        (lambda ()
  65.          (pcs-clear-registers)
  66.          (fresh-line)
  67.          (display "[")
  68.          (display (length (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
  69.          (display "] ")
  70.          (if (member 'gc %pcs-stl-debug-flag) (gc #T))
  71.          (let ((problem (read)))
  72.            (flush-input)
  73.            (if (eof-object? problem)
  74.            (display "[End of file read by SCHEME-TOP-LEVEL]")
  75.            (begin
  76.              (putprop '%PCS-STL-HISTORY
  77.                   (cons (list problem)
  78.                     (getprop '%PCS-STL-HISTORY
  79.                          %pcs-stl-history))
  80.                   %pcs-stl-history)
  81.              (let* ((answer (eval (if (member 'debug %pcs-stl-debug-flag)
  82.                           (compile (list 'BEGIN
  83.                              '(%BEGIN-DEBUG)
  84.                              problem))
  85.                           problem)))
  86.                 (next (fluid scheme-top-level)))
  87.                (when (not (eq? answer *the-non-printing-object*))
  88.                  (write answer))
  89.                (putprop '%PCS-STL-HISTORY
  90.                 (cons (cons problem answer)
  91.                       (cdr (getprop '%PCS-STL-HISTORY
  92.                             %pcs-stl-history)))
  93.                 %pcs-stl-history)
  94.                (if (eq? next ==reset==)
  95.                (more)
  96.                (next)))))))))
  97.      (set! (fluid scheme-top-level) ==scheme-reset==)
  98.      *the-non-printing-object*))))
  99.  
  100.   ; %C accesses the nth user command
  101.   ; %D accesses the result of the nth user command
  102.  
  103.   (define %c                        ; %C
  104.     (lambda (n)
  105.       (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
  106.     (and (positive? n)
  107.          (< n (length history))
  108.          (car (list-ref (reverse history) n))))))
  109.  
  110.   (define %d                        ; %D
  111.     (lambda (n)
  112.       (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
  113.     (and (positive? n)
  114.          (< n (length history))
  115.          (cdr (list-ref (reverse history) n))))))
  116. ) ;begin
  117.  
  118. (reset-scheme-top-level)
  119.  
  120. (let ((file (%system-file-name "PATCH.PCS")))
  121.   (when (file-exists? file)             ; system patches
  122.     (load file)))
  123.  
  124.  
  125. ;; Pathnames read as text from a file will have single backslashes.
  126. ;; This doubles them so a read-from-string type operation will work on them.
  127. ;; It's used for the .INI processing following.
  128. (define (double-slashify string)
  129.   (let loop ((m 0)
  130.          (n 0)
  131.          (new (make-string (string-length string) '())))
  132.     (if (= m (string-length string))
  133.     new
  134.     (begin
  135.       (string-set! new n (string-ref string m))
  136.       (if (char=? (string-ref string m) #\\)
  137.           (let ((newer (make-string (add1 (string-length new)) '())))
  138.         (substring-move-left! new 0 (+ n 1) newer 0)
  139.         (string-set! newer (+ n 1) #\\)
  140.         (loop (+ m 1) (+ n 2) newer))
  141.           (loop (+ m 1) (+ n 1) new))))))
  142.  
  143.  
  144. ;; Now come the dos-key history management utilities...
  145. (define (push-history item)
  146.   (cond
  147.     ((null? item) '())
  148.     ((atom? item) (%push-history item))
  149.     (else (push-history (cdr item))
  150.           (push-history (car item)))))
  151.  
  152. (define (get-history)
  153.   (letrec
  154.     ((loop (lambda (n)
  155.              (let ((item (%get-history n)))
  156.                (if (string? item) (cons item (loop (1+ n))))))))
  157.     (loop 0)))
  158.  
  159. (%set-global-environment user-initial-environment)
  160.  
  161.  
  162. ;; Note:  You can make your own toplevel function the system's toplevel by
  163. ;; assigning it to the fluid variable SCHEME-TOP-LEVEL from the .INI file.
  164. ;; Don't invoke it yourself.  After loading the .INI file, this file's
  165. ;; final SCHEME-RESET initializes the VM for toplevel recovery
  166. ;; (in case of errors) and invokes the toplevel function automatically.
  167.  
  168.  
  169. (cond ((null? pcs-initial-arguments)          ;no args at all, use scheme.ini
  170.        (when (file-exists? "scheme.ini")
  171.          (load "scheme.ini")))
  172.       (else
  173.     (let ((pia-files
  174.         (map symbol->string
  175.              (let ((x (read (open-input-string
  176.                       (double-slashify (car pcs-initial-arguments))))))
  177.                (if (pair? x) x (list x))))))    ;handle nonlist file
  178.       (let loop ((rest pia-files) (ini-files '()))  ;handle list files
  179.         (let ((f (car rest)))
  180.           (cond ((null? rest)
  181.              (when (null? ini-files)        ;no ini's given, use scheme.ini
  182.                (set! ini-files '("scheme.ini")))
  183.              (for-each            ;load several ini's
  184.                (lambda (f)
  185.              (when (file-exists? f) (load f)))
  186.                ini-files))
  187.             ((< (string-length f) 4)        ;file sans extension--assumed ini
  188.              (loop (cdr rest) (cons f ini-files)))
  189.             ((substring-ci=? f (- (string-length f) 4) (string-length f)
  190.                      ".app" 0 4)
  191.              (loop (cdr rest) ini-files))  ;don't reload compiler
  192.             (else
  193.               (loop (cdr rest) (cons f ini-files))) ;assume fasl file
  194.             ))))))
  195.  
  196.  
  197. (scheme-reset)        ; must be last operation!
  198.